;; This file is part of GNUnet
;; Copyright (C) 2004-2013, 2016 GNUnet e.V.
;; Copyright (C) 2021 Maxime Devos
;;
;; GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later

;; Author: Christian Grothoff
;; Author: Nathan Evans
;; ^^ TODO: not visible yet, but once more parts are ported ...
;; Author: Maxime Devos (Scheme port)
(define-library (gnu gnunet dht client)
  (export connect
	  disconnect!
	  put!
	  cancel-put!
	  start-get!
	  filter-get:known-results!
	  stop-get!
	  ;; Extended API: monitor
	  start-monitor!
	  stop-monitor!)
  (import (gnu extractor enum)
	  (gnu gnunet block)
	  (gnu gnunet concurrency repeated-condition)
	  (gnu gnunet mq)
	  (gnu gnunet mq handler)
	  (gnu gnunet mq-impl stream)
	  (gnu gnunet mq envelope)
	  (only (guile)
		pk define-syntax-rule define* error
		make-hash-table hashq-set!)
	  (only (ice-9 atomic)
		make-atomic-box atomic-box-ref atomic-box-set!)
	  (only (gnu extractor enum)
		symbol-value)
	  (only (fibers)
		spawn-fiber)
	  (only (fibers conditions)
		make-condition signal-condition! wait-operation)
	  (only (fibers operations)
		perform-operation choice-operation)
	  (only (gnu gnunet mq error-reporting)
		report-error)
	  (gnu gnunet dht struct)
	  (only (gnu gnunet crypto struct)
		/peer-identity)
	  (only (gnu gnunet message protocols)
		message-type)
	  (only (gnu gnunet netstruct syntactic)
		read% sizeof)
	  (only (gnu gnunet utils bv-slice)
		slice-length slice/read-only)
	  (only (rnrs base)
		and >= = quote * + - define begin ... let*
		quote case else values apply let cond if >
		<= expt assert integer?)
	  (only (rnrs control)
		unless when)
	  (only (rnrs records syntactic)
		define-record-type))
  (begin
    (define-record-type (<server> %make-server server?)
      (fields (immutable request-close?/box server-request-close?/box)
	      (immutable request-close-condition
			 server-request-close-condition)
	      ;; Hash table from new <get> to #true.  These get operations
	      ;; are not yet sent to the services, and not yet queued for
	      ;; sending.  Guile's hash tables are thread safe, so no locking
	      ;; is required.
	      (immutable new-get-operations server-new-get-operations)
	      ;; After adding new entries to 'new-get-operations', this
	      ;; ‘repeated condition’ is triggered to interrupt the fiber
	      ;; responsible for processing the new get operations.
	      (immutable new-get-operaton-trigger
			 server-new-get-operation-trigger)
	      ;; Atomic box holding an unsigned 64-bit integer.
	      (immutable next-unique-id/box server-next-unique-id/box)))

    (define-record-type (<get> %make-get get?)
      (fields (immutable server get:server)
	      (immutable found get:iterator)
	      (immutable key get:key)
	      (immutable unique-id get:unique-id)
	      (immutable desired-replication-level
			 get:desired-replication-level)
	      (immutable type get:type)
	      (immutable options get:options)))

    (define (fresh-id server)
      "Generate a fresh numeric ID to use for communication with @var{server}."
      ;; Atomically increment the ‘next unique id’, but avoid
      ;; overflow (the GNUnet network structures limit the ‘unique id’
      ;; to being less than (expt 2 64)).
      (%%bind-atomic-boxen
       ((next-unique-id (server-next-unique-id/box server) swap!))
       (let loop ((expected next-unique-id))
	 (define desired (+ 1 expected))
	 ;; TODO(low-priority): handle overflow without errors
	 (when (> desired (- (expt 2 64) 1))
	   (error "you overflowed an 64-bit counter."))
	 (define actual (swap! expected desired))
	 (if (= expected actual)
	     ;; Always returning ‘desired’ instead of ‘expected’ would work
	     ;; too.
	     expected
	     (loop actual)))))

    (define* (start-get! server type key found
			 #:key (desired-replication-level 3))
      "Perform an asynchronous GET operation on the DHT, and return a handle
to control the GET operation.  Search for a block of type @var{type} (a
@code{block-type} or its numeric value) and key @var{key}, a readable bytevector
slice.  Call @var{found} on every search result."
      ;; TODO: options, xquery ...
      (define canonical-type
	(cond ((integer? type)
	       (unless (and (<= 0 type (- (expt 2 32) 1)))
		 (error "block type out of bounds")
		 type))
	      (#t
	       (assert (block-type? type))
	       (value->index type))))
      (define handle (%make-get server found key (fresh-id server)
				desired-replication-level
				type
				0)) ; TODO
      (hashq-set! (server-new-get-operations server) handle #t)
      ;; Asynchronuously process the new get request.
      (trigger-condition! (server-new-get-operation-trigger server))
      handle)

    (define-syntax-rule (well-formed?/path-length slice type (field ...) compare)
      "Verify the TYPE message in @var{slice}, which has @var{field ...} ...
(e.g. one or more of get-path-length or put-path-length) and corresponding
/peer-identities at the end of the message is well-formed -- i.e., check if the length
of @var{slice} corresponds to the size of @var{type} and the get-path-length and
put-path-length.

@var{compare} must be @code{=} if no additional payload follows, or @code{>=}
if an addiional payload may follow.  The message type and the size in the
message header is assumed to be correct."
      ;; Warning: slice is evaluated multiple times!
      (and (>= (slice-length slice) (sizeof type '()))
	   (let* ((header (slice/read-only slice 0 (sizeof type '())))
		  (extra-size (- (slice-length slice) (sizeof type '())))
		  (field (read% type '(field) slice))
		  ...)
	     (compare extra-size (* (+ field ...) (sizeof /peer-identity '()))))))

    ;; TODO reduce duplication with (gnu gnunet nse client) --- maybe introduce
    ;; (gnu gnunet client) as in the C implementation?
    (define (disconnect! server)
      "Asynchronuously disconnect from the DHT service and stop reconnecting,
even if not connected.  This is an idempotent operation."
      (atomic-box-set! (server-request-close?/box server) #t)
      (signal-condition! (server-request-close-condition server)))

    (define* (connect config #:key (spawn spawn-fiber))
      "Connect to the DHT service in the background."
      (define request-close?/box (make-atomic-box #f))
      (define request-close-condition (make-condition))
      (reconnect request-close?/box request-close-condition config
		 #:spawn spawn)
      (%make-server request-close?/box request-close-condition
		    (make-hash-table) (make-repeated-condition)
		    ;; Any ‘small’ exact natural number will do.
		    (make-atomic-box 0)))

    (define* (reconnect request-close?/box request-close-condition config
			#:key (spawn spawn-fiber)
			#:rest rest)
      (define handlers
	(message-handlers
	 (message-handler
	  (type (symbol-value message-type msg:dht:monitor:get))
	  ((interpose exp) exp)
	  ((well-formed? slice)
	   ;; The C implementation verifies that 'get-path-length' at most
	   ;; (- (expt 2 16) 1), but this seems only to prevent integer overflow,
	   ;; which cannot happen in Scheme due to the use of bignums.
	   ;;
	   ;; This message does _not_ have a payload, so use = instead of >=.
	   (well-formed?/path-length slice /:msg:dht:monitor:get-response
				     (get-path-length) =))
	  ((handle! slice) ???))
 	 (message-handler
	  (type (symbol-value message-type msg:dht:monitor:get-response))
	  ((interpose exp) exp)
	  ((well-formed? slice)
	   ;; Payload follows, hence >= instead of =.
	   (well-formed?/path-length slice /:msg:dht:monitor:get-response
				     (get-path-length put-path-length) >=))
	  ((handle! slice) ???))
 	 (message-handler
	  (type (symbol-value message-type msg:dht:monitor:put))
	  ((interpose exp) exp)
	  ((well-formed? slice)
	   ;; Payload follows, hence >= instead of =.
	   (well-formed?/path-length slice /:msg:dht:monitor:put
				     (put-path-length) >=))
	  ((handle! slice) ???))
 	 (message-handler
	  (type (symbol-value message-type msg:dht:client:result))
	  ((interpose exp) exp)
	  ((well-formed? slice)
	   ;; Actual data follows, hence >= instead of =.
	   (well-formed?/path-length slice /:msg:dht:client:result
				     (get-path-length put-path-length) >=))
	  ((handle! slice) ???))))
      ;; TODO: abstract duplication in (gnu gnunet nse client)
      (define mq-closed (make-condition))
      (define (error-handler error . arguments)
	(case error
	  ((connection:connected)
	   (pk 'todo-connected)
	   'todo)
	  ((input:regular-end-of-file input:premature-end-of-file)
	   (signal-condition! mq-closed)
	   (unless (atomic-box-ref request-close?/box)
	     (apply reconnect request-close?/box request-close-condition
		    config rest)))
	  ((connection:interrupted)
	   (values))
	  (else
	   (apply report-error error arguments)
	   (close-queue! mq))))
      (define (request-close-handler)
	(perform-operation
	 (choice-operation
	  (wait-operation request-close-condition)
	  ;; Make sure the fiber exits after a reconnect.
	  (wait-operation mq-closed)))
	(close-queue! mq))
      (define mq (connect/fibers config "dht" handlers error-handler
				 #:spawn spawn))
      (spawn request-close-handler)
      ;; TODO: use new-get-operations
      'todo)))
